home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / css.el.z / css.el
Encoding:
Text File  |  1998-05-21  |  34.9 KB  |  1,056 lines
  1. ;;; css.el -- Cascading Style Sheet parser
  2. ;; Author: wmperry
  3. ;; Created: 1997/12/24 19:32:37
  4. ;; Version: 1.42
  5. ;; Keywords: 
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. (eval-and-compile
  31.   (require 'cl)
  32.   (require 'font)
  33.   )
  34.  
  35. (if (not (fboundp 'frame-char-height))
  36.     (defun frame-char-height (&optional frame)
  37.       "Height in pixels of a line in the font in frame FRAME.
  38. If FRAME is omitted, the selected frame is used.
  39. For a terminal frame, the value is always 1."
  40.       (font-height (face-font 'default frame))))
  41.  
  42. (if (not (fboundp 'frame-char-width))
  43.     (defun frame-char-width (&optional frame)
  44.       "Width in pixels of characters in the font in frame FRAME.
  45. If FRAME is omitted, the selected frame is used.
  46. For a terminal screen, the value is always 1."
  47.       (font-width (face-font 'default frame))))
  48.  
  49. ;; CBI = Cant Be Implemented - due to limitations in emacs/xemacs
  50. ;; NYI = Not Yet Implemented - due to limitations of space/time
  51. ;; NYPI = Not Yet Partially Implemented - possible partial support, eventually
  52.  
  53. (defconst css-properties
  54.   '(;; Property name    Inheritable?   Type of data
  55.     ;; Base CSS level 1 properties: http://www.w3.org/pub/WWW/TR/REC-CSS1
  56.     ;; Font properties, Section 5.2
  57.     [font-family      t              string-list]
  58.     [font-style       t              symbol]
  59.     [font-variant     t              symbol]
  60.     [font-weight      t              weight]
  61.     [font-size        t              height]
  62.     [font             nil            font]
  63.  
  64.     ;; Color and background properties, Section 5.3
  65.     [color            t              color]
  66.     [background       nil            color-shorthand]
  67.     [background-color nil            color]
  68.     [background-image nil            url]    ; NYI
  69.     [background-repeat nil           symbol] ; CBI
  70.     [background-attachment nil       symbol] ; CBI
  71.     [background-position nil         symbol] ; CBI
  72.  
  73.     ;; Text properties, Section 5.4
  74.     [word-spacing     t              length] ; CBI
  75.     [letter-spacing   t              length] ; CBI
  76.     [text-decoration  t              symbol-list]
  77.     [vertical-align   nil            symbol]
  78.     [text-transform   t              symbol]
  79.     [text-align       t              symbol]
  80.     [text-indent      t              length] ; NYI
  81.     [line-height      t              length] ; CBI
  82.  
  83.     ;; Box properties, Section 5.5
  84.     [margin           nil            boundary-shorthand]
  85.     [margin-left      nil            length]
  86.     [margin-right     nil            length]
  87.     [margin-top       nil            length]
  88.     [margin-bottom    nil            length]
  89.     [padding          nil            boundary-shorthand]
  90.     [padding-left     nil            length]
  91.     [padding-right    nil            length]
  92.     [padding-top      nil            length]
  93.     [padding-bottom   nil            length]
  94.     [border           nil            border-shorthand]
  95.     [border-left      nil            border]
  96.     [border-right     nil            border]
  97.     [border-top       nil            border]
  98.     [border-bottom    nil            border]
  99.     [border-top-width nil            nil]
  100.     [border-right-width nil          nil]
  101.     [border-bottom-width nil         nil]
  102.     [border-left-width nil           nil]
  103.     [border-width     nil            boundary-shorthand]
  104.     [border-color     nil            color]
  105.     [border-style     nil            symbol]
  106.     [width            nil            length] ; NYPI
  107.     [height           nil            length] ; NYPI
  108.     [float            nil            symbol]
  109.     [clear            nil            symbol]
  110.  
  111.     ;; Classification properties, Section 5.6
  112.     [display          nil            symbol]
  113.     [list-style-type  t              symbol]
  114.     [list-style-image t              url]
  115.     [list-style-position t           symbol]
  116.     [list-style       nil            list-style]
  117.     [white-space      t              symbol]
  118.  
  119.     ;; These are for specifying speech properties (ACSS-style)
  120.     ;; http://www.w3.org/pub/WWW/Style/CSS/Speech/NOTE-ACSS
  121.  
  122.     ;; General audio properties, Section 3
  123.     [volume           t              string] ; Needs its own type?
  124.     [pause-before     nil            time]
  125.     [pause-after      nil            time]
  126.     [pause            nil            pause]
  127.     [cue-before       nil            string]
  128.     [cue-after        nil            string]
  129.     [cue-during       nil            string]
  130.     [cue              nil            string] ; Needs its own type?
  131.  
  132.     ;; Spatial properties, Section 4
  133.     [azimuth          t              angle]
  134.     [elevation        t              elevation]
  135.  
  136.     ;; Speech properties, Section 5
  137.     [speed            t              string]
  138.     [voice-family     t              string-list]
  139.     [pitch            t              string]
  140.     [pitch-range      t              percentage]
  141.     [stress           t              percentage]
  142.     [richness         t              percentage]
  143.     [speak-punctuation t             symbol]
  144.     [speak-date       t              symbol]
  145.     [speak-numeral    t              symbol]
  146.     [speak-time       t              symbol]
  147.  
  148.     ;; Proposed printing extensions
  149.     ;; http://www.w3.org/pub/WWW/Style/Group/WD-PRINT-961220
  150.     ;; These apply only to pages (@page directive)
  151.     [size             nil            symbol]
  152.     [orientation      nil            symbol]
  153.     [margin-inside    nil            length]
  154.     ;; These apply to the document
  155.     [page-break-before nil           symbol]
  156.     [page-break-after  nil           symbol]
  157.     
  158.     ;; These are for specifying speech properties (Raman-style)
  159.     [voice-family     t              string]
  160.     [gain             t              symbol]
  161.     [left-volume      t              integer]
  162.     [right-volume     t              integer]
  163.     [pitch            t              integer]
  164.     [pitch-range      t              integer]
  165.     [stress           t              integer]
  166.     [richness         t              integer]
  167.     )
  168.   "A description of the various CSS properties and how to interpret them.")
  169.  
  170. (put 'font 'css-shorthand t)
  171. (put 'background 'css-shorthand t)
  172. (put 'margin 'css-shorthand t)
  173. (put 'padding 'css-shorthand t)
  174. (put 'border 'css-shorthand t)
  175. (put 'list-style 'css-shorthand t)
  176.  
  177. (mapcar
  178.  (lambda (entry)
  179.    (put (aref entry 0) 'css-inherit (aref entry 1))
  180.    (put (aref entry 0) 'css-type    (aref entry 2)))
  181.  css-properties)
  182.  
  183. (defconst css-weights
  184.   '(nil                    ;never used
  185.     :extra-light
  186.     :light
  187.     :demi-light
  188.     :medium
  189.     :normal
  190.     :demi-bold
  191.     :bold
  192.     :extra-bold
  193.     )
  194.   "List of CSS font weights.")
  195.  
  196. (defvar css-syntax-table
  197.   (copy-syntax-table emacs-lisp-mode-syntax-table)
  198.   "The syntax table for parsing stylesheets")
  199.  
  200. (modify-syntax-entry ?' "\"" css-syntax-table)
  201. (modify-syntax-entry ?` "\"" css-syntax-table)
  202. (modify-syntax-entry ?{ "(" css-syntax-table)
  203. (modify-syntax-entry ?} ")" css-syntax-table)
  204.  
  205. (eval-when-compile
  206.   (defvar css-scratch-val nil)
  207.   (defvar css-scratch-id nil)
  208.   (defvar css-scratch-class nil)
  209.   (defvar css-scratch-possibles nil)
  210.   (defvar css-scratch-current nil)
  211.   (defvar css-scratch-classes nil)
  212.   (defvar css-scratch-class-match nil)
  213.   (defvar css-scratch-current-rule nil)
  214.   (defvar css-scratch-current-value nil)
  215.   )
  216.  
  217. (defconst css-running-xemacs
  218.   (string-match "XEmacs" (emacs-version))
  219.   "Whether we are running in XEmacs or not.")
  220.  
  221. (defsubst css-replace-regexp (regexp to-string)
  222.   (goto-char (point-min))
  223.   (while (re-search-forward regexp nil t)
  224.     (replace-match to-string t nil)))
  225.  
  226. (defun css-contextual-match (rule stack)
  227.   (let ((ancestor)
  228.     (p-args)
  229.     (p-class)
  230.     (matched t))
  231.     (while rule
  232.       (setq ancestor (assq (caar rule) stack))
  233.       (if (not ancestor)
  234.       (setq rule nil
  235.         matched nil)
  236.     (setq p-args (cdr ancestor)
  237.           p-class (or (cdr-safe (assq 'class p-args)) t))
  238.     (if (not (equal p-class (cdar rule)))
  239.         (setq matched nil
  240.           rule nil)))
  241.       (setq rule (cdr rule)))
  242.     matched))
  243.  
  244. (defsubst css-get-internal (tag args)
  245.   (declare (special tag sheet element-stack default))
  246.   (setq css-scratch-id (or (cdr-safe (assq 'id args))
  247.                (cdr-safe (assq 'name args)))
  248.     css-scratch-class (or (cdr-safe (assq 'class args)) t)  
  249.     css-scratch-possibles (cl-gethash tag sheet))
  250.   (while css-scratch-possibles
  251.     (setq css-scratch-current (car css-scratch-possibles)
  252.       css-scratch-current-rule (car css-scratch-current)
  253.       css-scratch-current-value (cdr css-scratch-current)
  254.       css-scratch-classes (if (listp (car css-scratch-current-rule))
  255.                   (cdar css-scratch-current-rule)
  256.                 (cdr css-scratch-current-rule))
  257.       css-scratch-class-match t
  258.       css-scratch-possibles (cdr css-scratch-possibles))
  259.     (if (eq t css-scratch-classes)
  260.     (setq css-scratch-classes nil))
  261.     (if (eq t css-scratch-class)
  262.     (setq css-scratch-class nil))
  263.     (while css-scratch-classes
  264.       (if (not (member (pop css-scratch-classes) css-scratch-class))
  265.       (setq css-scratch-class-match nil
  266.         css-scratch-classes nil)))
  267.     (cond
  268.      ((and (listp (car css-scratch-current-rule)) css-scratch-class-match)
  269.       ;; Contextual!
  270.       (setq css-scratch-current-rule (cdr css-scratch-current-rule))
  271.       (if (css-contextual-match css-scratch-current-rule element-stack)
  272.       (setq css-scratch-val
  273.         (append css-scratch-val css-scratch-current-value)))
  274.       )
  275.      (css-scratch-class-match
  276.       (setq css-scratch-val (append css-scratch-val css-scratch-current-value))
  277.       )
  278.      (t
  279.       nil))
  280.     )
  281.   )
  282.  
  283. (defsubst css-get (tag args &optional sheet element-stack)
  284.   (setq css-scratch-val nil
  285.     css-scratch-class (or (cdr-safe (assq 'class args)) t))
  286.  
  287.   ;; check for things without the class
  288.   (if (listp css-scratch-class)
  289.       (css-get-internal tag nil))
  290.  
  291.   ;; check for global class values
  292.   (css-get-internal '*document args)
  293.  
  294.   ;; Now check for things with the class - they will be stuck on the front
  295.   ;; of the list, which will mean we do the right thing
  296.   (css-get-internal tag args)
  297.  
  298.   ;; Defaults are up to the calling application to provide
  299.   css-scratch-val)
  300.  
  301. (defun css-ancestor-get (info ancestors sheet)
  302.   ;; Inheritable property, check ancestors
  303.   (let (cur)
  304.     (while ancestors
  305.       (setq cur (car ancestors)
  306.          css-scratch-val (css-get info (car cur) (cdr cur) sheet)
  307.          ancestors (if css-scratch-val nil (cdr ancestors)))))
  308.   css-scratch-val)  
  309.  
  310. (defun css-split-selector (tag)
  311.   ;; Return a list 
  312.   (cond
  313.    ((string-match " " tag)        ; contextual
  314.     (let ((tags (split-string tag "[ \t]+"))
  315.       (result nil))
  316.       (while tags
  317.     (setq result (cons (css-split-selector (car tags)) result)
  318.           tags (cdr tags)))
  319.       result))
  320.    ((string-match "[:\\.]" tag)
  321.     (let ((tag (if (= (match-beginning 0) 0)
  322.            '*document
  323.          (intern (downcase (substring tag 0 (match-beginning 0))))))
  324.       (rest (substring tag (match-beginning 0) nil))
  325.       (classes nil))
  326.       (while (string-match "^[:\\.][^:\\.]+" rest)
  327.     (if (= ?. (aref rest 0))
  328.         (setq classes (cons (substring rest 1 (match-end 0)) classes))
  329.       (setq classes (cons (substring rest 0 (match-end 0)) classes)))
  330.     (setq rest (substring rest (match-end 0) nil)))
  331.       (setq classes (sort classes 'string-lessp))
  332.       (cons tag classes)))
  333.    ((string-match "^#" tag)        ; id selector
  334.     (cons '*document (list tag)))
  335.    (t
  336.     (cons (intern (downcase tag)) t)
  337.     )
  338.    )
  339.   )
  340.  
  341. (defun css-applies-to (st nd)
  342.   (let ((results nil)
  343.     (save-pos nil))
  344.     (narrow-to-region st nd)
  345.     (goto-char st)
  346.     (skip-chars-forward " \t\r\n")
  347.     (while (not (eobp))
  348.       (setq save-pos (point))
  349.       (skip-chars-forward "^,")
  350.       (skip-chars-backward " \r\t\n")
  351.       (setq results (cons (css-split-selector
  352.                (buffer-substring save-pos (point))) results))
  353.       (skip-chars-forward ", \t\r\n"))
  354.     (widen)
  355.     results))
  356.  
  357. (defun css-split-font-shorthand (font)
  358.   ;; [<font-weight> || <font-style>]? <font-size> [ / <line-height> ]? <font-family>
  359.   (let (weight size height family retval)
  360.     (if (not (string-match " *\\([0-9.]+[^ /]+\\)" font))
  361.     (progn
  362.       (message "Malformed font shorthand: %s" font)
  363.       nil)
  364.       (setq weight (if (/= 0 (match-beginning 0))
  365.                (substring font 0 (match-beginning 0)))
  366.         size (match-string 1 font)
  367.         font (substring font (match-end 0) nil))
  368.       (if (string-match " */ *\\([^ ]+\\) *" font)
  369.       ;; they specified a line-height as well
  370.       (setq height (match-string 1 font)
  371.         family (substring font (match-end 0) nil))
  372.     (if (string-match "^[ \t]+" font)
  373.         (setq family (substring font (match-end 0) nil))
  374.       (setq family font)))
  375.       (if weight
  376.       (push (cons 'font-weight (css-expand-value 'weight weight)) retval))
  377.       (if size
  378.       (push (cons 'font-size (css-expand-length size)) retval))
  379.       (if height
  380.       (push (cons 'line-height (css-expand-length height t)) retval))
  381.       (if family
  382.       (push (cons 'font-family (css-expand-value 'string-list family)) retval))
  383.       retval)))
  384.  
  385. (if (not (fboundp 'frame-char-height))
  386.     (defun frame-char-height (&optional frame)
  387.       "Height in pixels of a line in the font in frame FRAME.
  388. If FRAME is omitted, the selected frame is used.
  389. For a terminal frame, the value is always 1."
  390.       (font-height (face-font 'default frame))))
  391.  
  392. (defun css-expand-length (spec &optional height)
  393.   (cond
  394.    ((not (stringp spec)) spec)
  395.    ((string-equal spec "auto") nil)
  396.    ((and (string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)%" spec)
  397.      (fboundp 'frame-char-height))
  398.     ;; A percentage
  399.     (setq spec (/ (string-to-int (match-string 1 spec)) 100.0))
  400.     (if height
  401.     (round (* (frame-char-height) spec))
  402.       (max 0 (round (* (frame-char-width) spec)))))
  403.    ((string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)%" spec)
  404.     ;; No frame-char-width/height
  405.     (setq spec (/ (string-to-int (match-string 1 spec)) 100.0))
  406.     (if height
  407.     (max 0 (round (* (/ (frame-pixel-height) (frame-height)) spec)))
  408.       (max 0 (round (* (/ (frame-pixel-width) (frame-width)) spec)))))
  409.    ((string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)e[mx]" spec)
  410.     ;; Character based
  411.     (max 0 (round (string-to-number (match-string 1 spec)))))
  412.    (t
  413.     (truncate (font-spatial-to-canonical spec)))
  414.    )
  415.   )
  416.  
  417. (defsubst css-unhex-char (x)
  418.   (if (> x ?9)
  419.       (if (>= x ?a)
  420.       (+ 10 (- x ?a))
  421.     (+ 10 (- x ?A)))
  422.     (- x ?0)))
  423.  
  424. (defsubst css-pow (x n)
  425.   (apply '* (make-list n x)))
  426.  
  427. (defun css-unhex (x)
  428.   (let ((ord (length x))
  429.     (rval 0))
  430.     (while (> ord 0)
  431.       (setq rval (+ rval
  432.             (* (css-pow 16 (- (length x) ord))
  433.                (css-unhex-char (aref x (1- ord)))))
  434.         ord (1- ord)))
  435.     rval))
  436.  
  437. (defmacro css-symbol-list-as-regexp (&rest keys)
  438.   (` (eval-when-compile
  439.        (concat "^\\("
  440.            (mapconcat 'symbol-name
  441.               (quote (, keys))
  442.               "\\|") "\\)$"))))
  443.  
  444. (defun css-expand-color (color)
  445.   (cond
  446.    ((string-match "^\\(transparent\\|none\\)$" color)
  447.     (setq color nil))
  448.    ((string-match "^#" color)
  449.     (let (r g b)
  450.       (cond
  451.        ((string-match "^#...$" color)
  452.     ;; 3-char rgb spec, expand out to six chars by replicating
  453.     ;; digits, not adding zeros.
  454.     (setq r (css-unhex (make-string 2 (aref color 1)))
  455.           g (css-unhex (make-string 2 (aref color 2)))
  456.           b (css-unhex (make-string 2 (aref color 3)))))
  457.        ((string-match "^#\\(..\\)\\(..\\)\\(..\\)$" color)
  458.     (setq r (css-unhex (match-string 1 color))
  459.           g (css-unhex (match-string 2 color))
  460.           b (css-unhex (match-string 3 color))))
  461.        (t
  462.     (setq color (substring color 1))
  463.     (let* ((n (/ (length color) 3))
  464.            (max (float (css-pow 16 n))))
  465.       (setq r (css-unhex (substring color 0 n))
  466.         g (css-unhex (substring color n (* n 2)))
  467.         b (css-unhex (substring color (* n 2) (* n 3)))
  468.         r (round (* (/ r max) 255))
  469.         g (round (* (/ g max) 255))
  470.         b (round (* (/ b max) 255))))))
  471.       (setq color (vector 'rgb r g b))))
  472.    ((string-match "^rgb *( *\\([0-9]+\\)[, ]+\\([0-9]+\\)[, ]+\\([0-9]+\\) *) *$" color)
  473.     ;; rgb(r,g,b) 0 - 255, cutting off at 255
  474.     (setq color (vector
  475.          'rgb
  476.          (min (string-to-int (match-string 1 color)) 255)
  477.          (min (string-to-int (match-string 2 color)) 255)
  478.          (min (string-to-int (match-string 3 color)) 255))))
  479.    ((string-match "^rgb *( *\\([0-9]+\\) *%[, ]+\\([0-9]+\\) *%[, ]+\\([0-9]+\\) *% *) *$" color)
  480.     ;; rgb(r%,g%,b%) 0 - 100%, cutting off at 100%
  481.     (let ((r (min (string-to-number (match-string 1 color)) 100.0))
  482.       (g (min (string-to-number (match-string 2 color)) 100.0))
  483.       (b (min (string-to-number (match-string 3 color)) 100.0)))
  484.       (setq r (round (* r 2.55))
  485.         g (round (* g 2.55))
  486.         b (round (* b 2.55))
  487.         color (vector 'rgb r g b))))
  488.     (t
  489.      ;; Hmmm... pass it through unmangled and hope the underlying
  490.      ;; windowing system can handle it.
  491.      )
  492.     )
  493.   color
  494.   )
  495.  
  496. (defun css-expand-value (type value)
  497.   (if value
  498.       (case type
  499.     (length                ; CSS, Section 6.1
  500.      (setq value (css-expand-length value)))
  501.     (height
  502.      (setq value (css-expand-length value t)))
  503.     (percentage            ; CSS, Section 6.2
  504.      (setq value (/ (string-to-number value)
  505.             (if (fboundp 'float) (float 100) 1))))
  506.     (color                ; CSS, Section 6.3
  507.      (setq value (css-expand-color value)))
  508.     (url                ; CSS, Section 6.4
  509.      (declare (special url purl))
  510.      (if (string-match "url *(\\([^ )]+\\) *)" value)
  511.          (setq value (match-string 1 value)))
  512.      (if (string-match " *\\([^ ]+\\) *" value)
  513.          (setq value (match-string 1 value)))
  514.      (setq value (url-expand-file-name value (or url purl))))
  515.     (angle                ; ACSS, Section 2.2.1
  516.      )
  517.     (time                ; ACSS, Section 2.2.2
  518.      (let ((val (string-to-number value))
  519.            (units 'ms))
  520.        (if (string-match "^[0-9]+ *\\([a-zA-Z.]+\\)" value)
  521.            (setq units (intern (downcase (match-string 1 value)))))
  522.        (setq value (case units
  523.              ((s second seconds)
  524.               val)
  525.              ((min minute minutes)
  526.               (* val 60))
  527.              ((hr hour hours)
  528.               (* val 60 60))
  529.              ((day days)
  530.               (* val 24 60 60))
  531.              (otherwise
  532.               (/ val (float 1000)))))))
  533.     (elevation            ; ACSS, Section 4.2
  534.      (if (string-match
  535.           (css-symbol-list-as-regexp below level above higher lower) value)
  536.          (setq value (intern (downcase (match-string value 1)))
  537.            value (case value
  538.                (below -90)
  539.                (above 90)
  540.                (level 0)
  541.                (higher 45)
  542.                (lower -45)
  543.                ))
  544.        (setq value (css-expand-value 'angle value))))
  545.     (color-shorthand        ; CSS, Section 5.3.7
  546.      ;; color|image|repeat|attach|position
  547.      (let ((keys (split-string value " +"))
  548.            cur color image repeat attach position)
  549.        (while (setq cur (pop keys))
  550.          (cond
  551.           ((string-match "url" cur)    ; Only image can have a URL
  552.            (setq image (css-expand-value 'url cur)))
  553.           ((string-match "%" cur)    ; Only position can have a perc.
  554.            (setq position (css-expand-value 'percentage cur)))
  555.           ((string-match "repeat" cur) ; Only repeat
  556.            (setq repeat (intern (downcase cur))))
  557.           ((string-match "scroll\\|fixed" cur)
  558.            (setq attach (intern (downcase (substring cur
  559.                              (match-beginning 0)
  560.                              (match-end 0))))))
  561.           ((string-match (css-symbol-list-as-regexp
  562.                   top center bottom left right) cur)
  563.            )
  564.           (t
  565.            (setq color (css-expand-value 'color cur)))))
  566.        (setq value (list (cons 'background-color color)
  567.                  (cons 'background-image image)
  568.                  (cons 'background-repeat repeat)
  569.                  (cons 'background-attachment attach)
  570.                  (cons 'background-position position)))))
  571.     (font                ; CSS, Section 5.2.7
  572.      ;; [style | variant | weight]? size[/line-height]? family
  573.      (setq value (css-split-font-shorthand value)))
  574.     (border                ; width | style | color
  575.      ;; FIXME
  576.      )
  577.     (border-shorthand        ; width | style | color
  578.      ;; FIXME
  579.      )
  580.     (list-style            ; CSS, Section 5.6.6
  581.      ;; keyword | position | url
  582.      (setq value (split-string value "[ ,]+"))
  583.      (if (= (length value) 1)
  584.          (setq value (list (cons 'list-style-type
  585.                      (intern (downcase (car value))))))
  586.        (setq value (list (cons 'list-style-type
  587.                    (css-expand-value 'symbol (nth 0 value)))
  588.                  (cons 'list-style-position
  589.                    (css-expand-value 'symbol (nth 1 value)))
  590.                  (cons 'list-style-image
  591.                    (css-expand-value 'url (nth 2 value)))))))
  592.     (boundary-shorthand        ; CSS, Section 5.5.x
  593.      ;; length|percentage|auto {1,4}
  594.      (setq value (split-string value "[ ,]+"))
  595.      (let* ((top (intern (format "%s-top" type)))
  596.         (bottom (intern (format "%s-bottom" type)))
  597.         (left (intern (format "%s-left" type)))
  598.         (right (intern (format "%s-right" type))))
  599.        (setq top (cons top (css-expand-value (get top 'css-type)
  600.                          (nth 0 value)))
  601.          right (cons right (css-expand-value (get right 'css-type)
  602.                              (nth 1 value)))
  603.          bottom (cons bottom (css-expand-value (get bottom 'css-type)
  604.                                (nth 2 value)))
  605.          left (cons left (css-expand-value (get left 'css-type)
  606.                            (nth 3 value)))
  607.          value (list top right bottom left))))
  608.     (weight                ; CSS, Section 5.2.5
  609.      ;; normal|bold|bolder|lighter|[1-9]00
  610.      (cond
  611.       ((string-match "^[0-9]+" value)
  612.        (setq value (/ (string-to-number value) 100)
  613.          value (or (nth value css-weights) :bold)))
  614.       ((string-match (css-symbol-list-as-regexp normal bold bolder lighter)
  615.              value)
  616.        (setq value (intern (downcase (concat ":" value)))))
  617.       (t (setq value (intern ":normal")))))
  618.     ;; The rest of these deal with how we handle things internally
  619.     ((symbol integer)        ; Read it in
  620.      (setq value (read (downcase value))))
  621.     (symbol-list            ; A space/comma delimited symlist
  622.      (setq value (downcase value)
  623.            value (split-string value "[ ,]+")
  624.            value (mapcar 'intern value)))
  625.     (string-list            ; A space/comma delimited list
  626.      (setq value (split-string value " *, *")))
  627.     (otherwise            ; Leave it as is
  628.      t)
  629.     )
  630.     )
  631.   value
  632.   )
  633.  
  634. (defun css-parse-args (st &optional nd)
  635.   ;; Return an assoc list of attribute/value pairs from a CSS style entry
  636.   (let (
  637.     name                ; From name=
  638.     value                ; its value
  639.     results                ; Assoc list of results
  640.     name-pos            ; Start of XXXX= position
  641.     val-pos                ; Start of value position
  642.     (case-fold-search t)
  643.     )
  644.     (save-excursion
  645.       (if (stringp st)
  646.       (progn
  647.         (set-buffer (get-buffer-create " *css-style-temp*"))
  648.         (set-syntax-table css-syntax-table)
  649.         (erase-buffer)
  650.         (insert st)
  651.         (setq st (point-min)
  652.           nd (point-max)))
  653.     (set-syntax-table css-syntax-table))
  654.       (save-restriction
  655.     (narrow-to-region st nd)
  656.     (goto-char (point-min))
  657.     (while (not (eobp))
  658.       (skip-chars-forward ";, \n\t")
  659.       (setq name-pos (point))
  660.       (skip-chars-forward "^ \n\t:,;")
  661.       (downcase-region name-pos (point))
  662.       (setq name (intern (buffer-substring name-pos (point))))
  663.       (skip-chars-forward " \t\n")
  664.       (if (not (eq (char-after (point)) ?:)) ; There is no value
  665.           (setq value nil)
  666.         (skip-chars-forward " \t\n:")
  667.         (setq val-pos (point)
  668.           value
  669.           (cond
  670.            ((or (= (or (char-after val-pos) 0) ?\")
  671.             (= (or (char-after val-pos) 0) ?'))
  672.             (buffer-substring (1+ val-pos)
  673.                       (condition-case ()
  674.                       (prog2
  675.                           (forward-sexp 1)
  676.                           (1- (point))
  677.                         (skip-chars-forward "\""))
  678.                     (error
  679.                      (skip-chars-forward "^ \t\n")
  680.                      (point)))))
  681.            (t
  682.             (buffer-substring val-pos
  683.                       (progn
  684.                     (skip-chars-forward "^;")
  685.                     (skip-chars-backward " \t")
  686.                     (point)))))))
  687.       (setq value (css-expand-value (get name 'css-type) value))
  688.       (if (get name 'css-shorthand)
  689.           (setq results (append value results))
  690.         (setq results (cons (cons name value) results)))
  691.       (skip-chars-forward ";, \n\t"))
  692.     results))))
  693.  
  694. (defun css-handle-media-directive (data active)
  695.   (let (type)
  696.     (if (string-match "\\([^ \t\r\n{]+\\)" data)
  697.     (setq type (intern (downcase (substring data (match-beginning 1)
  698.                         (match-end 1))))
  699.           data (substring data (match-end 1)))
  700.       (setq type 'unknown))
  701.     (if (string-match "^[ \t\r\n]*{" data)
  702.     (setq data (substring data (match-end 0))))
  703.     (if (memq type active)
  704.     (save-excursion
  705.       (insert data)))))
  706.  
  707. (defun css-handle-import (data)
  708.   (let (url)
  709.     (setq url (css-expand-value 'url data))
  710.     (and url
  711.      (let ((url-working-buffer (generate-new-buffer-name " *styleimport*"))
  712.            (url-mime-accept-string
  713.         "text/css ; level=2")
  714.            (sheet nil))
  715.        (save-excursion
  716.          (set-buffer (get-buffer-create url-working-buffer))
  717.          (setq url-be-asynchronous nil)
  718.          (url-retrieve url)
  719.          (css-clean-buffer)
  720.          (setq sheet (buffer-string))
  721.          (set-buffer-modified-p nil)
  722.          (kill-buffer (current-buffer)))
  723.        (insert sheet)))))
  724.  
  725. (defun css-clean-buffer ()
  726.   ;; Nuke comments, etc.
  727.   (goto-char (point-min))
  728.   (let ((save-pos nil))
  729.     (while (search-forward "/*" nil t)
  730.       (setq save-pos (- (point) 2))
  731.       (delete-region save-pos
  732.              (if (search-forward "*/" nil t)
  733.              (point)
  734.                (end-of-line)
  735.                (point)))))
  736.   (goto-char (point-min))
  737.   (delete-matching-lines "^[ \t\r]*$")    ; Nuke blank lines
  738.   (css-replace-regexp "^[ \t\r]+" "")    ; Nuke whitespace at beg. of line
  739.   (css-replace-regexp "[ \t\r]+$" "")    ; Nuke whitespace at end of line
  740.   (goto-char (point-min)))
  741.  
  742. (if css-running-xemacs
  743.     (defun css-color-light-p (color-or-face)
  744.       (let (face color)
  745.     (cond
  746.      ((or (facep color-or-face)
  747.           (and (symbolp color-or-face)
  748.            (find-face color-or-face)))
  749.       (setq color (specifier-instance (face-background color-or-face))))
  750.      ((color-instance-p color-or-face)
  751.       (setq color color-or-face))
  752.      ((color-specifier-p color-or-face)
  753.       (setq color (specifier-instance color-or-face)))
  754.      ((stringp color-or-face)
  755.       (setq color (make-color-instance color-or-face)))
  756.      (t (signal 'wrong-type-argument 'color-or-face-p)))
  757.     (if color
  758.         (not (< (apply '+ (color-instance-rgb-components color))
  759.             (/ (apply '+ (color-instance-rgb-components
  760.                   (make-color-instance "white"))) 3)))
  761.       t)))
  762.   (defun css-color-values (color)
  763.     (cond
  764.      ((eq window-system 'x)
  765.       (x-color-values color))
  766.      ((eq window-system 'pm)
  767.       (pm-color-values color))
  768.      ((eq window-system 'ns)
  769.       (ns-color-values color))
  770.      (t nil)))
  771.   (defun css-color-light-p (color-or-face)
  772.     (let (colors)
  773.       (cond
  774.        ((null window-system)
  775.     nil)
  776.        ((facep color-or-face)
  777.     (setq color-or-face (face-background color-or-face))
  778.     (if (null color-or-face)
  779.         (setq color-or-face (cdr-safe
  780.                  (assq 'background-color (frame-parameters)))))
  781.     (setq colors (css-color-values color-or-face)))
  782.        ((stringp color-or-face)
  783.     (setq colors (css-color-values color-or-face)))
  784.        ((font-rgb-color-p color-or-face)
  785.     (setq colors (list (font-rgb-color-red color-or-face)
  786.                (font-rgb-color-green color-or-face)
  787.                (font-rgb-color-blue color-or-face))))
  788.        (t
  789.     (signal 'wrong-type-argument 'color-or-face-p)))
  790.       (not (< (apply '+ colors)
  791.           (/ (apply '+ (css-color-values "white")) 3)))))
  792.   )
  793.  
  794. (defun css-active-device-types (&optional device)
  795.   (let ((types (list 'all
  796.              (if css-running-xemacs 'xemacs 'emacs)
  797.              (if (css-color-light-p 'default) 'light 'dark)))
  798.     (type (device-type device)))
  799.     ;; For reasons I don't really want to get into, emacspeak and TTY
  800.     ;; are mutually exclusive for most of our purposes (insert-before,
  801.     ;; xetc)
  802.     (if (featurep 'emacspeak)
  803.     (setq types (cons 'speech types))
  804.       (if (eq type 'tty)
  805.       (setq types (cons 'tty types))))
  806.     (cond
  807.      ((eq 'color (device-class))
  808.       (if (not (device-bitplanes))
  809.       (setq types (cons 'color types))
  810.     (setq types
  811.           (append
  812.            (list (intern (format "%dbit-color"
  813.                      (device-bitplanes)))
  814.              (intern (format "%dbit"
  815.                      (device-bitplanes)))
  816.              'color) types))
  817.     (if (= 24 (device-bitplanes))
  818.         (setq types (cons 'truecolor types)))))
  819.      ((eq 'grayscale (device-class))
  820.       (setq types (append (list (intern (format "%dbit-grayscale"
  821.                         (device-bitplanes)))
  822.                 'grayscale)
  823.               types)))
  824.      ((eq 'mono (device-class))
  825.       (setq types (append (list 'mono 'monochrome) types)))
  826.      (t
  827.       (setq types (cons 'unknown types))))
  828.     ;; FIXME: Remove me when the real 3.0 comes out
  829.     (if (and (memq 'tty types) (memq 'color types))
  830.     (setq types (cons 'ansi-tty types)))
  831.     types))
  832.  
  833. (defmacro css-rule-specificity-internal (rule)
  834.   (`
  835.    (progn
  836.      (setq tmp (cdr (, rule)))
  837.      (if (listp tmp)
  838.      (while tmp
  839.        (if (= ?# (aref (car tmp) 0))
  840.            (incf a)
  841.          (incf b))
  842.        (setq tmp (cdr tmp)))))))
  843.  
  844. (defsubst css-specificity (rule)
  845.   ;; To find specificity, according to the september 1996 CSS draft
  846.   ;; a = # of ID attributes in the selector
  847.   ;; b = # of class attributes in the selector
  848.   ;; c = # of tag names in the selector
  849.   (let ((a 0) (b 0) (c 0) cur tmp)
  850.     (if (not (listp (car rule)))
  851.     (css-rule-specificity-internal rule)
  852.       (setq c (length rule))
  853.       (while rule
  854.     (css-rule-specificity-internal (pop rule))))
  855.     (+ (* 100 a) (* 10 b) c)
  856.     )
  857.   )
  858.  
  859. (defun css-copy-stylesheet (sheet)
  860.   (let ((new (make-hash-table :size (hash-table-count sheet))))
  861.     (cl-maphash
  862.      (function
  863.       (lambda (k v)
  864.     (cl-puthash k (copy-tree v) new))) sheet)
  865.     new))
  866.  
  867. (defsubst css-store-rule (attrs applies-to)
  868.   (declare (special sheet))
  869.   (let (rules cur tag node)
  870.     (while applies-to
  871.       (setq cur (pop applies-to)
  872.         tag (car cur))
  873.       (if (listp tag)
  874.       (setq tag (car tag)))
  875.       (setq rules (cl-gethash tag sheet))
  876.       (cond
  877.        ((null rules)
  878.     ;; First rule for this tag.  Create new ruleset
  879.     (cl-puthash tag (list (cons cur attrs)) sheet))
  880.        ((setq node (assoc cur rules))
  881.     ;; Similar rule already exists, splice in our information
  882.     (setcdr node (append attrs (cdr node))))
  883.        (t
  884.     ;; First rule for this particular combination of tag/ancestors/class.
  885.     ;; Slap it onto the existing set of rules and push back into sheet.
  886.     (setq rules (cons (cons cur attrs) rules))
  887.     (cl-puthash tag rules sheet))
  888.        )
  889.       )
  890.     )
  891.   )
  892.  
  893. (defun css-parse (url &optional string inherit)
  894.   (let (
  895.     (url-mime-accept-string
  896.      "text/css ; level=2")
  897.     (save-pos nil)
  898.     (applies-to nil)        ; List of tags to apply style to
  899.     (attrs nil)            ; List of name/value pairs
  900.     (att nil)
  901.     (cur nil)
  902.     (val nil)
  903.     (device-type nil)
  904.     (purl (url-view-url t))
  905.     (active-device-types (css-active-device-types (selected-device)))
  906.     (sheet inherit))
  907.     (if (not sheet)
  908.     (setq sheet (make-hash-table :size 13 :test 'eq)))
  909.     (save-excursion
  910.       (set-buffer (get-buffer-create
  911.            (generate-new-buffer-name " *style*")))
  912.       (set-syntax-table css-syntax-table)
  913.       (erase-buffer)
  914.       (if url (url-insert-file-contents url))
  915.       (goto-char (point-max))
  916.       (if string (insert string))
  917.       (css-clean-buffer)
  918.       (goto-char (point-min))
  919.       (while (not (eobp))
  920.     (setq save-pos (point))
  921.     (cond
  922.      ;; *sigh* SGML comments are being used to 'hide' data inlined
  923.      ;; with the <style> tag from older browsers.
  924.      ((or (looking-at "<!--+")    ; begin
  925.           (looking-at "--+>"))    ; end
  926.       (goto-char (match-end 0)))
  927.      ;; C++ style comments
  928.      ((looking-at "[ \t]*//")
  929.       (end-of-line))
  930.      ;; Pre-Processor directives
  931.      ((looking-at "[ \t\r]*@\\([^ \t\r\n]\\)")
  932.       (let (data directive)
  933.         (skip-chars-forward " @\t\r") ; Past any leading whitespace
  934.         (setq save-pos (point))
  935.         (skip-chars-forward "^ \t\r\n") ; Past the @ directive
  936.         (downcase-region save-pos (point))
  937.         (setq directive (intern (buffer-substring save-pos (point))))
  938.         (skip-chars-forward " \t\r")
  939.         (setq save-pos (point))
  940.         (cond
  941.          ((looking-at "[^{]*\\({\\)")
  942.           (goto-char (match-beginning 1))
  943.           (forward-sexp 1)
  944.           (setq data (buffer-substring save-pos (1- (point)))))
  945.          ((looking-at "[\"']+")
  946.           (setq save-pos (1+ save-pos))
  947.           (forward-sexp 1)
  948.           (setq data (buffer-substring save-pos (1- (point)))))
  949.          (t
  950.           (skip-chars-forward "^;")))
  951.         (if (not data)
  952.         (setq data (buffer-substring save-pos (point))))
  953.         (setq save-pos (point))
  954.         (case directive
  955.          (import (css-handle-import data))
  956.          (media (css-handle-media-directive data active-device-types))
  957.          (t (message "Unknown directive in stylesheet: @%s" directive)))))
  958.      ;; Giving us some output device information, old way
  959.      ((looking-at "[ \t\r]*:\\([^: \n]+\\):")
  960.       (downcase-region (match-beginning 1) (match-end 1))
  961.       (setq device-type (intern (buffer-substring (match-beginning 1)
  962.                               (match-end 1))))
  963.       (goto-char (match-end 0))
  964.       (if (not (memq device-type active-device-types))
  965.           ;; Not applicable to us... skip the info
  966.           (progn
  967.         (if (re-search-forward ":[^:{ ]*:" nil t)
  968.             (goto-char (match-beginning 0))
  969.           (goto-char (point-max))))))
  970.      ;; Default is to treat it like a stylesheet declaration
  971.      (t
  972.       (skip-chars-forward "^{")
  973.       ;;(downcase-region save-pos (point))
  974.       (setq applies-to (css-applies-to save-pos (point)))
  975.       (skip-chars-forward "^{")
  976.       (setq save-pos (point))
  977.       (condition-case ()
  978.           (forward-sexp 1)
  979.         (error (goto-char (point-max))))
  980.       (skip-chars-backward "\r}")
  981.       (subst-char-in-region save-pos (point) ?\n ? )
  982.       (subst-char-in-region save-pos (point) ?\r ? )
  983.       ;; This is for not choking on garbage at the end of the buffer.
  984.       ;; I get bit by this every once in a while when going through my
  985.       ;; socks gateway.
  986.       (if (eobp)
  987.           nil
  988.         (setq attrs (css-parse-args (1+ save-pos) (point)))
  989.         (skip-chars-forward "}\r\n")
  990.         (css-store-rule attrs applies-to))
  991.       )
  992.      )
  993.     (skip-chars-forward " \t\r\n"))
  994.       (set-buffer-modified-p nil)
  995.       (kill-buffer (current-buffer)))
  996.     sheet)
  997.   )
  998.  
  999. ;; Tools for pretty-printing an existing stylesheet.
  1000. (defun css-rule-name (rule)
  1001.   (cond
  1002.    ((listp (car rule))            ; Contextual
  1003.     (mapconcat 'css-rule-name 
  1004.            (reverse rule) " "))
  1005.    ((listp (cdr rule))            ; More than one class
  1006.     (let ((classes (cdr rule))
  1007.       (rval (symbol-name (car rule))))
  1008.       (while classes
  1009.     (setq rval (concat rval
  1010.                (if (= (aref (car classes) 0) ?:)
  1011.                    (pop classes)
  1012.                  (concat "." (pop classes))))))
  1013.       rval))
  1014.    (t
  1015.     (symbol-name (car rule)))))
  1016.  
  1017. (defun css-display (sheet)
  1018.   (with-output-to-temp-buffer "CSS Stylesheet"
  1019.     (set-buffer standard-output)
  1020.     (indented-text-mode)
  1021.     (insert "# Stylesheet auto-regenerated by css.el\n#\n"
  1022.         "# This is a mixture of the default stylesheet and any\n"
  1023.         "# styles specified by the document.  The rules are in no\n"
  1024.         "# particular order.\n\n")
  1025.     (let (tmp cur goal-col)
  1026.       (cl-maphash
  1027.        (function
  1028.     (lambda (k v)
  1029.       (while v
  1030.         (setq cur (pop v))
  1031.         (insert (css-rule-name (car cur)))
  1032.         (insert " { ")
  1033.         (setq goal-col (point))
  1034.         (insert "\n")
  1035.         ;; Display the rules
  1036.         (setq tmp (cdr cur))
  1037.         (let (prop val)
  1038.           (while tmp
  1039.         (setq prop (caar tmp)
  1040.               val (cdar tmp)
  1041.               tmp (cdr tmp))
  1042.         (case (get prop 'css-type)
  1043.           (symbol-list
  1044.            (setq val (mapconcat 'symbol-name val ",")))
  1045.           (weight
  1046.            (setq val (substring (symbol-name val) 1 nil)))
  1047.           (otherwise
  1048.            nil)
  1049.           )
  1050.         (insert (format "  %s: %s;\n" prop val))))
  1051.         (insert "}\n\n");
  1052.         )))
  1053.        sheet))))
  1054.  
  1055. (provide 'css)
  1056.